home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / csimp.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  10.8 KB  |  364 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module csimp)
  13.  
  14. (declare-top (special rsn* $factlim $exponentialize 
  15.           var varlist genvar $%emode $ratprint 
  16.           nn* dn* $errexp sqrt3//2 sqrt2//2 -sqrt2//2 -sqrt3//2
  17.           $demoivre errorsw islinp $keepfloat $ratfac)
  18.      (*lexpr $ratcoef)
  19.      (genprefix %))
  20.  
  21. (load-macsyma-macros rzmac)
  22.  
  23. (declare-top (special $NOINTEGRATE $LHOSPITALLIM $TLIMSWITCH $LIMSUBST
  24.               $ABCONVTEST COMPLEX-LIMIT PLOGABS $INTANALYSIS ))
  25.  
  26.  
  27. (setq $demoivre nil rsn* nil $nointegrate nil $lhospitallim 4 
  28.       $tlimswitch nil $limsubst nil $abconvtest nil
  29.       complex-limit nil plogabs nil $intanalysis t)
  30.  
  31. (defmvar %p%i '((mtimes) $%i $%pi))
  32. (defmvar fourth%pi '((mtimes) ((rat simp) 1 4) $%pi))
  33. (defmvar half%pi '((mtimes) ((rat simp) 1 2) $%pi))
  34. (defmvar %pi2 '((mtimes) 2 $%pi)) 
  35. (defmvar half%pi3 '((mtimes) ((rat simp) 3 2) $%pi)) 
  36. (defmvar $sumsplitfact t)    ;= nil minfactorial is applied after a factocomb.
  37. (defmvar $gammalim 1000000.)
  38.  
  39. (sloop for (a b) on 
  40.        '(%SIN %ASIN %COS %ACOS %TAN %ATAN
  41.      %COT %ACOT %SEC %ASEC %CSC %ACSC
  42.      %SINH %ASINH %COSH %ACOSH %TANH %ATANH
  43.      %COTH %ACOTH %SECH %ASECH %CSCH %ACSCH)
  44.        by 'cddr
  45.    do  (PUTPROP A B '$INVERSE) (PUTPROP B A '$INVERSE))
  46.  
  47. (defmfun $demoivre (exp)
  48.  (let ($exponentialize nexp)
  49.       (cond ((atom exp) exp)
  50.         ((and (eq (caar exp) 'mexpt) (eq (cadr exp) '$%e)
  51.           (setq nexp (demoivre (caddr exp))))
  52.          nexp)
  53.         (t (recur-apply #'$demoivre exp)))))
  54.  
  55. (defun demoivre (l) 
  56.        (cond ($exponentialize
  57.           (merror "Demoivre and Exponentialize may not both be true"))
  58.          (t (setq l (islinear l '$%i))
  59.         (and l (not (equal (car l) 0))
  60.              (m* (m^ '$%e (cdr l))
  61.              (m+ (list '(%cos) (car l))
  62.                  (m* '$%i (list '(%sin) (car l))))))))) 
  63.  
  64. (defun islinear (exp var1) 
  65.        ;;;If exp is of the form a*var1+b where a is freeof var1
  66.        ;;; then (a . b) is returned else nil
  67.        ((lambda (a) (cond ((freeof var1 a)
  68.                (cons a (MAXIMA-SUBSTITUTE 0 var1 exp)))))
  69.     ((lambda (islinp) (sdiff exp var1)) t)))
  70.  
  71. (DEFMFUN $partition (e var1)
  72.   (prog (k)
  73.     (setq e (mratcheck e) var1 (getopr var1))
  74.     (cond (($listp e)
  75.            (return (do ((l (cdr e) (cdr l)) (l1) (l2) (x))
  76.                ((null l) (list '(mlist simp)
  77.                        (cons '(mlist simp) (nreverse l1))
  78.                        (cons '(mlist simp) (nreverse l2))))
  79.                (setq x (mratcheck (car l)))
  80.                (cond ((free x var1) (setq l1 (cons x l1)))
  81.                  (t (setq l2 (cons x l2)))))))
  82.           ((mplusp e) (setq e (cons '(mtimes) (cdr e)) k 0))
  83.           ((mtimesp e) (setq k 1))
  84.           (t
  85.            (merror "~M is an incorrect arg to PARTITION" e)))
  86.     (setq e (partition e var1 k))
  87.     (return (list '(mlist simp) (car e) (cdr e)))))
  88.  
  89. (defun partition (exp var1 k)  ; k is 1 for MTIMES and 0 for MPLUS.
  90.        (prog (const varbl op)
  91.          (setq op (cond ((= k 0) '(mplus)) (t '(mtimes))))
  92.          (cond ((or (alike1 exp var1) (not (eq (caar exp) 'mtimes)))
  93.             (return (cons k exp))))
  94.          (setq exp (cdr exp))
  95.     loop (cond ((free (car exp) var1) (setq const (cons (car exp) const)))
  96.            (t (setq varbl (cons (car exp) varbl))))
  97.          (cond ((null (setq exp (cdr exp)))
  98.             (return (cons (cond ((null const) k)
  99.                     ((null (cdr const)) (car const))
  100.                     (t (simplifya (cons op (nreverse const)) t)))
  101.                   (cond ((null varbl) k)
  102.                     ((null (cdr varbl)) (car varbl))
  103.                     (t (simplifya (cons op (nreverse varbl)) t)))))))
  104.          (go loop)))
  105.  
  106. ;To use this INTEGERINFO and *ASK* need to be special.
  107. ;(defun integerpw (x) 
  108. ; ((lambda (*ask*) 
  109. ;    (integerp10 (ssimplifya (sublis '((z** . 0) (*z* . 0)) x)))) 
  110. ;  t))
  111.  
  112. ;(defun integerp10 (x) 
  113. ; ((lambda (d) 
  114. ;   (cond ((or (null x) (not (free x '$%i))) nil)
  115. ;     ((mnump x) (integerp x))
  116. ;     ((setq d (assolike x integerinfo)) (eq d 'yes))
  117. ;     (*ask* (setq d (cond ((integerp x) 'yes) (t (needinfo x))))
  118. ;        (setq integerinfo (cons (list x d) integerinfo))
  119. ;        (eq d 'yes))))
  120. ; nil))
  121.  
  122. (setq var (maknam (explode 'foo))) 
  123.  
  124. (defun numden (e)
  125.  (prog (varlist) 
  126.        (setq varlist (list var))
  127.        (newvar (setq e (fmt e)))
  128.        (setq e (cdr (ratrep* e)))
  129.        (setq dn*
  130.          (simplifya (pdis (ratdenominator e))
  131.                 nil))
  132.        (setq nn*
  133.          (simplifya (pdis (ratnumerator e))
  134.                 nil))))
  135.  
  136. (defun fmt (exp) 
  137.   (let (nn*) 
  138.     (cond ((atom exp) exp)
  139.       ((mnump exp) exp)
  140.       ((eq (caar exp) 'mexpt)
  141.        (cond ((and (mnump (caddr exp))
  142.                (eq ($sign (caddr exp)) '$neg))
  143.           (list '(mquotient)
  144.             1
  145.             (cond ((equal (caddr exp) -1)
  146.                    (fmt (cadr exp)))
  147.                   (t (list (list (caar exp))
  148.                        (fmt (cadr exp))
  149.                        (timesk -1 (caddr exp)))))))
  150.          ((atom (caddr exp))
  151.           (list (list (caar exp))
  152.             (fmt (cadr exp))
  153.             (caddr exp)))
  154.          ((and (mtimesp (setq nn* (sratsimp (caddr exp))))
  155.                (mnump (cadr nn*))
  156.                (equal ($sign (cadr nn*)) '$neg))
  157.           (list '(mquotient)
  158.             1
  159.             (list (list (caar exp))
  160.                   (fmt (cadr exp))
  161.                   (cond ((equal (cadr nn*) -1)
  162.                      (cons '(mtimes)
  163.                        (cddr nn*)))
  164.                     (t (neg nn*))))))
  165.          ((eq (caar nn*) 'mplus)
  166.           (fmt (spexp (cdr nn*) (cadr exp))))
  167.          (t (cons (ncons (caar exp))
  168.               (mapcar #'fmt (cdr exp))))))
  169.       (t (cons (delsimp (car exp)) (mapcar #'fmt (cdr exp)))))))
  170.  
  171. (defun spexp (expl dn*) 
  172.      (cons '(mtimes) (mapcar #'(lambda (e) (list '(mexpt) dn* e)) expl)))
  173.  
  174. (defun subin (y x) (cond ((not (among var x)) x) (t (MAXIMA-SUBSTITUTE y var x))))
  175.  
  176. (DEFMFUN $rhs (eq)
  177.        (cond ((or (atom eq) (not (eq (caar eq) 'mequal))) 0) (t (caddr eq))))
  178.  
  179. (DEFMFUN $lhs (eq)
  180.        (cond ((or (atom eq) (not (eq (caar eq) 'mequal))) eq) (t (cadr eq))))
  181.  
  182. (defun ratgreaterp (x y)
  183.        (cond ((and (mnump x) (mnump y))
  184.           (great x y))
  185.          ((equal ($asksign (m- x y)) '$pos))))
  186.  
  187.  
  188.  
  189. (defun %especial (e) 
  190.   (prog (varlist y k j ans $%emode $ratprint genvar)
  191.     ((lambda ($float $keepfloat) 
  192.       (cond ((not (setq y (pip ($ratcoef e '$%i)))) (return nil)))
  193.       (setq j (trigred y))
  194.       (setq k ($expand (m+ e (m* -1 '$%pi '$%i y)) 1))
  195.       (setq ans (spang1 j t))) nil nil)
  196.     (cond ((among '%sin ans)
  197.            (cond ((equal y j) (return nil))
  198.              ((equal k 0)
  199.               (return (list '(mexpt simp)
  200.                     '$%e
  201.                     (m* %p%i j))))
  202.              (t (return (list '(mexpt simp)
  203.                       '$%e
  204.                       (m+ k (m* %p%i j))))))))
  205.     (setq y (spang1 j nil))
  206.     (return (mul2 (m^ '$%e k) (m+ y (m* '$%i ans))))))
  207.  
  208. (defun trigred (r) 
  209.        (prog (m n eo flag) 
  210.          (cond ((numberp r) (return (cond ((even r) 0) (t 1)))))
  211.          (setq m (cadr r))
  212.          (cond ((minusp m) (setq m (minus m)) (setq flag t)))
  213.          (setq n (caddr r))
  214.     loop (cond ((greaterp m n)
  215.             (setq m (difference m n))
  216.             (setq eo (not eo))
  217.             (go loop)))
  218.          (setq m (list '(rat)
  219.                (cond (flag (minus m)) (t m))
  220.                n))
  221.          (return (cond (eo (addk m (cond (flag 1) (t -1))))
  222.                (t m))))) 
  223.  
  224. (defun polyinx (exp x ind) 
  225.   (prog (genvar varlist var $ratfac) 
  226.     (setq var x)
  227.     (cond ((numberp exp)(return t))
  228.           ((polyp exp)
  229.            (cond (ind (go on))
  230.              (t (return t))))
  231.           (t (return nil)))
  232.    on    (setq genvar nil)
  233.     (setq varlist (list x))
  234.     (newvar exp)
  235.     (setq exp (cdr (ratrep* exp)))
  236.     (cond
  237.      ((or (numberp (cdr exp))
  238.           (not (eq (car (last genvar)) (cadr exp))))
  239.       (setq x (pdis (cdr exp)))
  240.       (return (cond ((eq ind 'leadcoef)
  241.              (div* (pdis (caddr (car exp))) x))
  242.             (t (setq exp (car exp))
  243.                  (div* (cond ((atom exp) exp)
  244.                      (t
  245.                       (pdis (list (car exp)
  246.                               (cadr exp)
  247.                               (caddr exp)))))
  248.                    x))
  249.             ))))))
  250.  
  251. (defun polyp (a)
  252.   (cond ((atom a) t)
  253.     ((memq (caar a) '(mplus mtimes))
  254.      (andmapc (function polyp) (cdr a)))
  255.     ((eq (caar a) 'mexpt)
  256.      (cond ((free (cadr a) var)
  257.         (free (caddr a) var))
  258.            (t (and (integerp (caddr a))
  259.                (greaterp (caddr a) 0)
  260.                (polyp (cadr a))))))
  261.     (t (andmapcar #'(lambda (subexp)
  262.               (free subexp var))
  263.               (cdr a)))))
  264.  
  265. (defun pip (e)
  266.   (prog (varlist d c) 
  267.     (newvar e)
  268.     (cond ((not (memq '$%pi varlist)) (return nil)))
  269.     (setq varlist '($%pi))
  270.     (newvar e)
  271.     (setq e (cdr (ratrep* e)))
  272.     (setq d (cdr e))
  273.     (cond ((not (atom d)) (return nil))
  274.           ((equal e '(0 . 1))
  275.            (setq c 0)
  276.            (go loop)))
  277.     (setq c (pterm (cdar e) 1))
  278.    loop (cond ((atom c)
  279.            (cond ((equal c 0) (return nil))
  280.              ((equal 1 d) (return c))
  281.              (t (return (list '(rat) c d))))))
  282.    (setq c (pterm (cdr c) 0))
  283.    (go loop)))
  284.  
  285. (defun spang1 (j ind) 
  286.        (prog (ang ep $exponentialize $float $keepfloat) 
  287.          (cond ((floatp j) (setq j (MAXIMA-RATIONALIZE j))
  288.                    (setq j (list '(rat simp) (car j) (cdr j)))))
  289.          (setq ang j)
  290.          (cond
  291.           (ind nil)
  292.           ((numberp j)
  293.            (cond ((zerop j) (return 1)) (t (return -1))))
  294.           (t (setq j
  295.                (trigred (add2* '((rat simp) 1 2)
  296.                        (list (car j)
  297.                          (minus (cadr j))
  298.                          (caddr j)))))))
  299.          (cond ((numberp j) (return 0))
  300.            ((mnump j) (setq j (cdr j))))
  301.          (return
  302.           (cond ((equal j '(1 2)) 1)
  303.             ((equal j '(-1 2)) -1)
  304.             ((or (equal j '(1 3))
  305.              (equal j '(2 3)))
  306.              sqrt3//2)
  307.             ((or (equal j '(-1 3))
  308.              (equal j '(-2 3)))
  309.              -sqrt3//2)
  310.             ((or (equal j '(1 6))
  311.              (equal j '(5 6)))
  312.              '((rat) 1 2))
  313.             ((or (equal j '(-1 6))
  314.              (equal j '(-5 6)))
  315.              '((rat) -1 2))
  316.             ((or (equal j '(1 4))
  317.              (equal j '(3 4)))
  318.              sqrt2//2)
  319.             ((or (equal j '(-1 4))
  320.              (equal j '(-3 4)))
  321.              -sqrt2//2)
  322.             (t (cond ((mnegp ang)
  323.                   (setq ang (timesk -1 ang) ep t)))
  324.                (setq ang (list '(mtimes simp)
  325.                        ang
  326.                        '$%pi))
  327.                (cond (ind (cond (ep (list '(mtimes simp)
  328.                           -1
  329.                           (list '(%sin simp)
  330.                             ang)))
  331.                     (t (list '(%sin simp)
  332.                          ang))))
  333.                  (t (list '(%cos simp) ang)))))))) 
  334.  
  335. ;(defun scsign (e) 
  336. ;       ((lambda (varlist genvar $ratprint) 
  337. ;     (setq *sign* nil)
  338. ;     (setq e (ratf e))
  339. ;     (setq *pform*
  340. ;           (simplifya (rdis (cond ((pminusp (cadr e))
  341. ;                       (setq *sign* t)
  342. ;                       (cons (pminus (cadr e))
  343. ;                         (cddr e)))
  344. ;                      (t (cdr e))))
  345. ;              nil)))
  346. ;    nil nil nil)) 
  347.  
  348. (defun archk (a b v) 
  349.      (simplify
  350.        (cond ((and (equal a 1) (equal b 1)) v)
  351.          ((and (equal b -1) (equal 1 a))
  352.           (list '(mtimes) -1 v))
  353.          ((equal 1 b)
  354.           (list '(mplus) '$%pi (list '(mtimes) -1 v)))
  355.          (t (list '(mplus) v (list '(mtimes) -1 '$%pi))))))
  356.  
  357. (defun genfind (h v)
  358. ;;; finds gensym coresponding to v h
  359.        (do ((varl (caddr h) (cdr varl))
  360.         (genl (cadddr h) (cdr genl)))
  361. ;;;is car of rat form
  362.        ((eq (car varl) v) (car genl))))
  363.  
  364.